home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / misc / volume13 / gmcalc / part09 < prev    next >
Encoding:
Text File  |  1990-06-05  |  57.2 KB  |  1,790 lines

  1. Newsgroups: comp.sources.misc
  2. From: daveg@csvax.caltech.edu (David Gillespie)
  3. Subject: v13i035: Emacs Calculator 1.01, part 09/19
  4. Sender: allbery@uunet.UU.NET (Brandon S. Allbery - comp.sources.misc)
  5.  
  6. Posting-number: Volume 13, Issue 35
  7. Submitted-by: daveg@csvax.caltech.edu (David Gillespie)
  8. Archive-name: gmcalc/part09
  9.  
  10. ---- Cut Here and unpack ----
  11. #!/bin/sh
  12. # this is part 9 of a multipart archive
  13. # do not concatenate these parts, unpack them in order with /bin/sh
  14. # file calc-ext.el continued
  15. #
  16. CurArch=9
  17. if test ! -r s2_seq_.tmp
  18. then echo "Please unpack part 1 first!"
  19.      exit 1; fi
  20. ( read Scheck
  21.   if test "$Scheck" != $CurArch
  22.   then echo "Please unpack part $Scheck next!"
  23.        exit 1;
  24.   else exit 0; fi
  25. ) < s2_seq_.tmp || exit 1
  26. echo "x - Continuing file calc-ext.el"
  27. sed 's/^X//' << 'SHAR_EOF' >> calc-ext.el
  28. X     1153 1163 1171 1181 1187 1193 1201 1213 1217 1223 1229 1231 1237 1249
  29. X     1259 1277 1279 1283 1289 1291 1297 1301 1303 1307 1319 1321 1327 1361
  30. X     1367 1373 1381 1399 1409 1423 1427 1429 1433 1439 1447 1451 1453 1459
  31. X     1471 1481 1483 1487 1489 1493 1499 1511 1523 1531 1543 1549 1553 1559
  32. X     1567 1571 1579 1583 1597 1601 1607 1609 1613 1619 1621 1627 1637 1657
  33. X     1663 1667 1669 1693 1697 1699 1709 1721 1723 1733 1741 1747 1753 1759
  34. X     1777 1783 1787 1789 1801 1811 1823 1831 1847 1861 1867 1871 1873 1877
  35. X     1879 1889 1901 1907 1913 1931 1933 1949 1951 1973 1979 1987 1993 1997
  36. X     1999 2003 2011 2017 2027 2029 2039 2053 2063 2069 2081 2083 2087 2089
  37. X     2099 2111 2113 2129 2131 2137 2141 2143 2153 2161 2179 2203 2207 2213
  38. X     2221 2237 2239 2243 2251 2267 2269 2273 2281 2287 2293 2297 2309 2311
  39. X     2333 2339 2341 2347 2351 2357 2371 2377 2381 2383 2389 2393 2399 2411
  40. X     2417 2423 2437 2441 2447 2459 2467 2473 2477 2503 2521 2531 2539 2543
  41. X     2549 2551 2557 2579 2591 2593 2609 2617 2621 2633 2647 2657 2659 2663
  42. X     2671 2677 2683 2687 2689 2693 2699 2707 2711 2713 2719 2729 2731 2741
  43. X     2749 2753 2767 2777 2789 2791 2797 2801 2803 2819 2833 2837 2843 2851
  44. X     2857 2861 2879 2887 2897 2903 2909 2917 2927 2939 2953 2957 2963 2969
  45. X     2971 2999 3001 3011 3019 3023 3037 3041 3049 3061 3067 3079 3083 3089
  46. X     3109 3119 3121 3137 3163 3167 3169 3181 3187 3191 3203 3209 3217 3221
  47. X     3229 3251 3253 3257 3259 3271 3299 3301 3307 3313 3319 3323 3329 3331
  48. X     3343 3347 3359 3361 3371 3373 3389 3391 3407 3413 3433 3449 3457 3461
  49. X     3463 3467 3469 3491 3499 3511 3517 3527 3529 3533 3539 3541 3547 3557
  50. X     3559 3571 3581 3583 3593 3607 3613 3617 3623 3631 3637 3643 3659 3671
  51. X     3673 3677 3691 3697 3701 3709 3719 3727 3733 3739 3761 3767 3769 3779
  52. X     3793 3797 3803 3821 3823 3833 3847 3851 3853 3863 3877 3881 3889 3907
  53. X     3911 3917 3919 3923 3929 3931 3943 3947 3967 3989 4001 4003 4007 4013
  54. X     4019 4021 4027 4049 4051 4057 4073 4079 4091 4093 4099 4111 4127 4129
  55. X     4133 4139 4153 4157 4159 4177 4201 4211 4217 4219 4229 4231 4241 4243
  56. X     4253 4259 4261 4271 4273 4283 4289 4297 4327 4337 4339 4349 4357 4363
  57. X     4373 4391 4397 4409 4421 4423 4441 4447 4451 4457 4463 4481 4483 4493
  58. X     4507 4513 4517 4519 4523 4547 4549 4561 4567 4583 4591 4597 4603 4621
  59. X     4637 4639 4643 4649 4651 4657 4663 4673 4679 4691 4703 4721 4723 4729
  60. X     4733 4751 4759 4783 4787 4789 4793 4799 4801 4813 4817 4831 4861 4871
  61. X     4877 4889 4903 4909 4919 4931 4933 4937 4943 4951 4957 4967 4969 4973
  62. X     4987 4993 4999 5003])
  63. X
  64. X
  65. X
  66. X
  67. X;;; Bitwise operations.
  68. X
  69. X(defun math-and (a b &optional w)   ; [I I I] [Public]
  70. X  (cond ((Math-messy-integerp w)
  71. X     (math-and a b (math-trunc w)))
  72. X    ((and w (not (integerp w)))
  73. X     (math-reject-arg w 'integerp))
  74. X    ((and (integerp a) (integerp b))
  75. X     (math-clip (logand a b) w))
  76. X    ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod))
  77. X     (math-binary-modulo-args 'math-and a b w))
  78. X    ((not (Math-num-integerp a))
  79. X     (math-reject-arg a 'integerp))
  80. X    ((not (Math-num-integerp b))
  81. X     (math-reject-arg b 'integerp))
  82. X    (t (math-clip (cons 'bigpos
  83. X                (math-and-bignum (math-binary-arg a w)
  84. X                         (math-binary-arg b w)))
  85. X              w)))
  86. X)
  87. X(fset 'calcFunc-and (symbol-function 'math-and))
  88. X
  89. X(defun math-binary-arg (a w)
  90. X  (if (not (Math-integerp a))
  91. X      (setq a (math-trunc a)))
  92. X  (if (Math-integer-negp a)
  93. X      (math-not-bignum (cdr (math-bignum-test (math-sub -1 a)))
  94. X               (math-abs (if w (math-trunc w) calc-word-size)))
  95. X    (cdr (Math-bignum-test a)))
  96. X)
  97. X
  98. X(defun math-binary-modulo-args (f a b w)
  99. X  (let (mod)
  100. X    (if (eq (car-safe a) 'mod)
  101. X    (progn
  102. X      (setq mod (nth 2 a)
  103. X        a (nth 1 a))
  104. X      (if (eq (car-safe b) 'mod)
  105. X          (if (equal mod (nth 2 b))
  106. X          (setq b (nth 1 b))
  107. X        (math-reject-arg b "Inconsistent modulos"))))
  108. X      (setq mod (nth 2 b)
  109. X        b (nth 1 b)))
  110. X    (if (Math-messy-integerp mod)
  111. X    (setq mod (math-trunc mod))
  112. X      (or (Math-integerp mod)
  113. X      (math-reject-arg mod 'integerp)))
  114. X    (let ((bits (math-integer-log2 mod)))
  115. X      (if bits
  116. X      (if w
  117. X          (if (/= w bits)
  118. X          (calc-record-why
  119. X           "Warning: Modulo inconsistent with word size"))
  120. X        (setq w bits))
  121. X    (calc-record-why "Warning: Modulo is not a power of 2"))
  122. X      (math-make-mod (if b
  123. X             (funcall f a b w)
  124. X               (funcall f a w))
  125. X             mod)))
  126. X)
  127. X
  128. X(defun math-and-bignum (a b)   ; [l l l]
  129. X  (and a b
  130. X       (let ((qa (math-div-bignum-digit a 512))
  131. X         (qb (math-div-bignum-digit b 512)))
  132. X     (math-mul-bignum-digit (math-and-bignum (math-norm-bignum (car qa))
  133. X                          (math-norm-bignum (car qb)))
  134. X                 512
  135. X                 (logand (cdr qa) (cdr qb)))))
  136. X)
  137. X
  138. X(defun math-or (a b &optional w)   ; [I I I] [Public]
  139. X  (cond ((Math-messy-integerp w)
  140. X     (math-or a b (math-trunc w)))
  141. X    ((and w (not (integerp w)))
  142. X     (math-reject-arg w 'integerp))
  143. X    ((and (integerp a) (integerp b))
  144. X     (math-clip (logior a b) w))
  145. X    ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod))
  146. X     (math-binary-modulo-args 'math-or a b w))
  147. X    ((not (Math-num-integerp a))
  148. X     (math-reject-arg a 'integerp))
  149. X    ((not (Math-num-integerp b))
  150. X     (math-reject-arg b 'integerp))
  151. X    (t (math-clip (cons 'bigpos
  152. X                (math-or-bignum (math-binary-arg a w)
  153. X                        (math-binary-arg b w)))
  154. X              w)))
  155. X)
  156. X(fset 'calcFunc-or (symbol-function 'math-or))
  157. X
  158. X(defun math-or-bignum (a b)   ; [l l l]
  159. X  (and (or a b)
  160. X       (let ((qa (math-div-bignum-digit a 512))
  161. X         (qb (math-div-bignum-digit b 512)))
  162. X     (math-mul-bignum-digit (math-or-bignum (math-norm-bignum (car qa))
  163. X                         (math-norm-bignum (car qb)))
  164. X                 512
  165. X                 (logior (cdr qa) (cdr qb)))))
  166. X)
  167. X
  168. X(defun math-xor (a b &optional w)   ; [I I I] [Public]
  169. X  (cond ((Math-messy-integerp w)
  170. X     (math-xor a b (math-trunc w)))
  171. X    ((and w (not (integerp w)))
  172. X     (math-reject-arg w 'integerp))
  173. X    ((and (integerp a) (integerp b))
  174. X     (math-clip (logxor a b) w))
  175. X    ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod))
  176. X     (math-binary-modulo-args 'math-xor a b w))
  177. X    ((not (Math-num-integerp a))
  178. X     (math-reject-arg a 'integerp))
  179. X    ((not (Math-num-integerp b))
  180. X     (math-reject-arg b 'integerp))
  181. X    (t (math-clip (cons 'bigpos
  182. X                (math-xor-bignum (math-binary-arg a w)
  183. X                         (math-binary-arg b w)))
  184. X              w)))
  185. X)
  186. X(fset 'calcFunc-xor (symbol-function 'math-xor))
  187. X
  188. X(defun math-xor-bignum (a b)   ; [l l l]
  189. X  (and (or a b)
  190. X       (let ((qa (math-div-bignum-digit a 512))
  191. X         (qb (math-div-bignum-digit b 512)))
  192. X     (math-mul-bignum-digit (math-xor-bignum (math-norm-bignum (car qa))
  193. X                          (math-norm-bignum (car qb)))
  194. X                 512
  195. X                 (logxor (cdr qa) (cdr qb)))))
  196. X)
  197. X
  198. X(defun math-diff (a b &optional w)   ; [I I I] [Public]
  199. X  (cond ((Math-messy-integerp w)
  200. X     (math-diff a b (math-trunc w)))
  201. X    ((and w (not (integerp w)))
  202. X     (math-reject-arg w 'integerp))
  203. X    ((and (integerp a) (integerp b))
  204. X     (math-clip (logand a (lognot b)) w))
  205. X    ((or (eq (car-safe a) 'mod) (eq (car-safe b) 'mod))
  206. X     (math-binary-modulo-args 'math-diff a b w))
  207. X    ((not (Math-num-integerp a))
  208. X     (math-reject-arg a 'integerp))
  209. X    ((not (Math-num-integerp b))
  210. X     (math-reject-arg b 'integerp))
  211. X    (t (math-clip (cons 'bigpos
  212. X                (math-diff-bignum (math-binary-arg a w)
  213. X                          (math-binary-arg b w)))
  214. X              w)))
  215. X)
  216. X(fset 'calcFunc-diff (symbol-function 'math-diff))
  217. X
  218. X(defun math-diff-bignum (a b)   ; [l l l]
  219. X  (and a
  220. X       (let ((qa (math-div-bignum-digit a 512))
  221. X         (qb (math-div-bignum-digit b 512)))
  222. X     (math-mul-bignum-digit (math-diff-bignum (math-norm-bignum (car qa))
  223. X                           (math-norm-bignum (car qb)))
  224. X                 512
  225. X                 (logand (cdr qa) (lognot (cdr qb))))))
  226. X)
  227. X
  228. X(defun math-not (a &optional w)   ; [I I] [Public]
  229. X  (cond ((Math-messy-integerp w)
  230. X     (math-not a (math-trunc w)))
  231. X    ((eq (car-safe a) 'mod)
  232. X     (math-binary-modulo-args 'math-not a nil w))
  233. X    ((and w (not (integerp w)))
  234. X     (math-reject-arg w 'integerp))
  235. X    ((not (Math-num-integerp a))
  236. X     (math-reject-arg a 'integerp))
  237. X    ((< (or w (setq w calc-word-size)) 0)
  238. X     (math-clip (math-not a (- w)) w))
  239. X    (t (math-normalize
  240. X        (cons 'bigpos
  241. X          (math-not-bignum (math-binary-arg a w)
  242. X                   w)))))
  243. X)
  244. X(fset 'calcFunc-not (symbol-function 'math-not))
  245. X
  246. X(defun math-not-bignum (a w)   ; [l l]
  247. X  (let ((q (math-div-bignum-digit a 512)))
  248. X    (if (<= w 9)
  249. X    (list (logand (lognot (cdr q))
  250. X              (1- (lsh 1 w))))
  251. X      (math-mul-bignum-digit (math-not-bignum (math-norm-bignum (car q))
  252. X                           (- w 9))
  253. X                  512
  254. X                  (logxor (cdr q) 511))))
  255. X)
  256. X
  257. X(defun math-lshift-binary (a &optional n w)   ; [I I] [Public]
  258. X  (setq a (math-trunc a)
  259. X    n (if n (math-trunc n) 1))
  260. X  (if (eq (car-safe a) 'mod)
  261. X      (math-binary-modulo-args 'math-lshift-binary a n w)
  262. X    (setq w (if w (math-trunc w) calc-word-size))
  263. X    (or (integerp w)
  264. X    (math-reject-arg w 'integerp))
  265. X    (or (Math-integerp a)
  266. X    (math-reject-arg a 'integerp))
  267. X    (or (Math-integerp n)
  268. X    (math-reject-arg n 'integerp))
  269. X    (if (< w 0)
  270. X    (math-clip (math-lshift-binary a n (- w)) w)
  271. X      (if (Math-integer-negp a)
  272. X      (setq a (math-clip a w)))
  273. X      (cond ((or (Math-lessp n (- w))
  274. X         (Math-lessp w n))
  275. X         0)
  276. X        ((< n 0)
  277. X         (math-quotient (math-clip a w) (math-power-of-2 (- n))))
  278. X        (t
  279. X         (math-clip (math-mul a (math-power-of-2 n)) w)))))
  280. X)
  281. X(fset 'calcFunc-lsh (symbol-function 'math-lshift-binary))
  282. X
  283. X(defun math-rshift-binary (a &optional n w)   ; [I I] [Public]
  284. X  (math-lshift-binary a (math-neg (or n 1)) w)
  285. X)
  286. X(fset 'calcFunc-rsh (symbol-function 'math-rshift-binary))
  287. X
  288. X(defun math-shift-binary (a &optional n w)   ; [I I] [Public]
  289. X  (if (not (Math-negp n))
  290. X      (math-lshift-binary a n w)
  291. X    (setq a (math-trunc a)
  292. X      n (if n (math-trunc n) 1))
  293. X    (if (eq (car-safe a) 'mod)
  294. X    (math-binary-modulo-args 'math-shift-binary a n w)
  295. X      (setq w (if w (math-trunc w) calc-word-size))
  296. X      (or (integerp w)
  297. X      (math-reject-arg w 'integerp))
  298. X      (or (Math-integerp a)
  299. X      (math-reject-arg a 'integerp))
  300. X      (or (Math-integerp n)
  301. X      (math-reject-arg n 'integerp))
  302. X      (if (< w 0)
  303. X      (math-clip (math-shift-binary a n (- w)) w)
  304. X    (if (Math-integer-negp a)
  305. X        (setq a (math-clip a w)))
  306. X    (let ((two-to-sizem1 (math-power-of-2 (1- w)))
  307. X          (sh (math-lshift-binary a n w)))
  308. X      (cond ((Math-natnum-lessp a two-to-sizem1)
  309. X         sh)
  310. X        ((Math-lessp n (- 1 w))
  311. X         (math-add (math-mul two-to-sizem1 2) -1))
  312. X        (t (let ((two-to-n (math-power-of-2 (- n))))
  313. X             (math-add (math-lshift-binary (math-add two-to-n -1)
  314. X                           (+ w n) w)
  315. X                   sh))))))))
  316. X)
  317. X(fset 'calcFunc-ash (symbol-function 'math-shift-binary))
  318. X
  319. X(defun math-rotate-binary (a &optional n w)   ; [I I] [Public]
  320. X  (setq a (math-trunc a)
  321. X    n (if n (math-trunc n) 1))
  322. X  (if (eq (car-safe a) 'mod)
  323. X      (math-binary-modulo-args 'math-rotate-binary a n w)
  324. X    (setq w (if w (math-trunc w) calc-word-size))
  325. X    (or (integerp w)
  326. X    (math-reject-arg w 'integerp))
  327. X    (or (Math-integerp a)
  328. X    (math-reject-arg a 'integerp))
  329. X    (or (Math-integerp n)
  330. X    (math-reject-arg n 'integerp))
  331. X    (if (< w 0)
  332. X    (math-clip (math-rotate-binary a n (- w)) w)
  333. X      (if (Math-integer-negp a)
  334. X      (setq a (math-clip a w)))
  335. X      (cond ((or (Math-integer-negp n)
  336. X         (not (Math-natnum-lessp n w)))
  337. X         (math-rotate-binary a (math-mod n w) w))
  338. X        (t
  339. X         (math-add (math-lshift-binary a (- n w) w)
  340. X               (math-lshift-binary a n w))))))
  341. X)
  342. X(fset 'calcFunc-rot (symbol-function 'math-rotate-binary))
  343. X
  344. X(defun math-clip (a &optional w)   ; [I I] [Public]
  345. X  (cond ((Math-messy-integerp w)
  346. X     (math-clip a (math-trunc w)))
  347. X    ((eq (car-safe a) 'mod)
  348. X     (math-binary-modulo-args 'math-clip a nil w))
  349. X    ((and w (not (integerp w)))
  350. X     (math-reject-arg w 'integerp))
  351. X    ((not (Math-num-integerp a))
  352. X     (math-reject-arg a 'integerp))
  353. X    ((< (or w (setq w calc-word-size)) 0)
  354. X     (setq a (math-clip a (- w)))
  355. X     (if (Math-natnum-lessp a (math-power-of-2 (- -1 w)))
  356. X         a
  357. X       (math-sub a (math-power-of-2 (- w)))))
  358. X    ((Math-negp a)
  359. X     (math-normalize (cons 'bigpos (math-binary-arg a w))))
  360. X    ((and (integerp a) (< a 1000000))
  361. X     (if (>= w 20)
  362. X         a
  363. X       (logand a (1- (lsh 1 w)))))
  364. X    (t
  365. X     (math-normalize
  366. X      (cons 'bigpos
  367. X        (math-clip-bignum (cdr (math-bignum-test (math-trunc a)))
  368. X                  w)))))
  369. X)
  370. X(fset 'calcFunc-clip (symbol-function 'math-clip))
  371. X
  372. X(defun math-clip-bignum (a w)   ; [l l]
  373. X  (let ((q (math-div-bignum-digit a 512)))
  374. X    (if (<= w 9)
  375. X    (list (logand (cdr q)
  376. X              (1- (lsh 1 w))))
  377. X      (math-mul-bignum-digit (math-clip-bignum (math-norm-bignum (car q))
  378. X                        (- w 9))
  379. X                  512
  380. X                  (cdr q))))
  381. X)
  382. X
  383. X
  384. X
  385. X;;;; Algebra.
  386. X
  387. X;;; Evaluate variables in an expression.
  388. X(defun math-evaluate-expr (x)  ; [Public]
  389. X  (math-normalize (math-evaluate-expr-rec x))
  390. X)
  391. X
  392. X(defun math-evaluate-expr-rec (x)
  393. X  (if (consp x)
  394. X      (setq x (cons (car x)
  395. X            (mapcar 'math-evaluate-expr-rec (cdr x)))))
  396. X  (if (eq (car-safe x) 'var)
  397. X      (if (and (boundp (nth 2 x))
  398. X           (symbol-value (nth 2 x))
  399. X           (not (eq (car-safe (symbol-value (nth 2 x)))
  400. X            'incomplete)))
  401. X      (let ((val (symbol-value (nth 2 x))))
  402. X        (if (eq (car-safe val) 'special-const)
  403. X        (if calc-symbolic-mode
  404. X            x
  405. X          val)
  406. X          val))
  407. X    x)
  408. X    x)
  409. X)
  410. X
  411. X
  412. X;;; Combine two terms being added, if possible.
  413. X(defun math-combine-sum (a b nega negb scalar-okay)
  414. X  (if (and scalar-okay (Math-objvecp a) (Math-objvecp b))
  415. X      (math-add-or-sub a b nega negb)
  416. X    (let ((amult 1) (bmult 1))
  417. X      (and (consp a)
  418. X       (cond ((and (eq (car a) '*)
  419. X               (Math-numberp (nth 1 a)))
  420. X          (setq amult (nth 1 a)
  421. X            a (nth 2 a)))
  422. X         ((and (eq (car a) '/)
  423. X               (Math-numberp (nth 2 a)))
  424. X          (setq amult (if (Math-integerp (nth 2 a))
  425. X                  (list 'frac 1 (nth 2 a))
  426. X                (math-div 1 (nth 2 a)))
  427. X            a (nth 1 a)))
  428. X         ((eq (car a) 'neg)
  429. X          (setq amult -1
  430. X            a (nth 1 a)))))
  431. X      (and (consp b)
  432. X       (cond ((and (eq (car b) '*)
  433. X               (Math-numberp (nth 1 b)))
  434. X          (setq bmult (nth 1 b)
  435. X            b (nth 2 b)))
  436. X         ((and (eq (car b) '/)
  437. X               (Math-numberp (nth 2 b)))
  438. X          (setq bmult (if (Math-integerp (nth 2 b))
  439. X                  (list 'frac 1 (nth 2 b))
  440. X                (math-div 1 (nth 2 b)))
  441. X            b (nth 1 b)))
  442. X         ((eq (car b) 'neg)
  443. X          (setq bmult -1
  444. X            b (nth 1 b)))))
  445. X      (and (equal a b)
  446. X       (progn
  447. X         (if nega (setq amult (math-neg amult)))
  448. X         (if negb (setq bmult (math-neg bmult)))
  449. X         (setq amult (math-add amult bmult))
  450. X         (math-mul amult a)))))
  451. X)
  452. X
  453. X(defun math-add-or-sub (a b aneg bneg)
  454. X  (if aneg (setq a (math-neg a)))
  455. X  (if bneg (setq b (math-neg b)))
  456. X  (math-add a b)
  457. X)
  458. X
  459. X;;; The following is expanded out four ways for speed.
  460. X(defun math-combine-prod (a b inva invb scalar-okay)
  461. X  (cond
  462. X   ((and scalar-okay (Math-objvecp a) (Math-objvecp b))
  463. X    (math-mul-or-div a b inva invb))
  464. X   ((and (eq (car-safe a) '^)
  465. X     inva
  466. X     (math-looks-negp (nth 2 a)))
  467. X    (math-mul (math-pow (nth 1 a) (math-neg (nth 2 a))) b))
  468. X   ((and (eq (car-safe b) '^)
  469. X     invb
  470. X     (math-looks-negp (nth 2 b)))
  471. X    (math-mul a (math-pow (nth 1 b) (math-neg (nth 2 b)))))
  472. X   (t (let ((apow 1) (bpow 1))
  473. X    (and (consp a)
  474. X         (cond ((and (eq (car a) '^)
  475. X             (or math-simplify-symbolic-powers
  476. X                 (Math-numberp (nth 2 a))))
  477. X            (setq apow (nth 2 a)
  478. X              a (nth 1 a)))
  479. X           ((and (eq (car a) 'calcFunc-sqrt))
  480. X            (setq apow '(frac 1 2)
  481. X              a (nth 1 a)))))
  482. X    (and (consp b)
  483. X         (cond ((and (eq (car b) '^)
  484. X             (or math-simplify-symbolic-powers
  485. X                 (Math-numberp (nth 2 b))))
  486. X            (setq bpow (nth 2 b)
  487. X              b (nth 1 b)))
  488. X           ((and (eq (car b) 'calcFunc-sqrt))
  489. X            (setq bpow '(frac 1 2)
  490. X              b (nth 1 b)))))
  491. X    (and (equal a b)
  492. X         (progn
  493. X           (if inva (setq apow (math-neg apow)))
  494. X           (if invb (setq bpow (math-neg bpow)))
  495. X           (setq apow (math-add apow bpow))
  496. X           (cond ((equal apow '(frac 1 2))
  497. X              (list 'calcFunc-sqrt a))
  498. X             ((equal apow '(frac -1 2))
  499. X              (math-div 1 (list 'calcFunc-sqrt a)))
  500. X             (t (math-pow a apow))))))))
  501. X)
  502. X(setq math-simplify-symbolic-powers nil)
  503. X
  504. X(defun math-mul-or-div (a b ainv binv)
  505. X  (if ainv
  506. X      (if binv
  507. X      (math-div (math-div 1 a) b)
  508. X    (math-div b a))
  509. X    (if binv
  510. X    (math-div a b)
  511. X      (math-mul a b)))
  512. X)
  513. X
  514. X
  515. X
  516. X;;; True if A comes before B in a canonical ordering of expressions.  [P X X]
  517. X(defun math-beforep (a b)   ; [Public]
  518. X  (cond ((and (Math-realp a) (Math-realp b))
  519. X     (let ((comp (math-compare a b)))
  520. X       (or (eq comp -1)
  521. X           (and (eq comp 0)
  522. X            (not (equal a b))
  523. X            (> (length (memq (car-safe a)
  524. X                     '(bigneg nil bigpos frac float)))
  525. X               (length (memq (car-safe b)
  526. X                     '(bigneg nil bigpos frac float))))))))
  527. X    ((Math-realp a) t)
  528. X    ((Math-realp b) nil)
  529. X    ((eq (car a) 'var)
  530. X     (if (eq (car b) 'var)
  531. X         (string-lessp (symbol-name (nth 1 a)) (symbol-name (nth 1 b)))
  532. X       (not (Math-numberp b))))
  533. X    ((eq (car b) 'var) (Math-numberp a))
  534. X    ((eq (car a) (car b))
  535. X     (while (and (setq a (cdr a) b (cdr b)) a
  536. X             (equal (car a) (car b))))
  537. X     (and b
  538. X          (or (null a)
  539. X          (math-beforep (car a) (car b)))))
  540. X    (t (string-lessp (symbol-name (car a)) (symbol-name (car b)))))
  541. X)
  542. X
  543. X
  544. X
  545. X(setq math-living-dangerously nil)   ; true if unsafe simplifications are okay.
  546. X
  547. X(defun math-simplify-extended (a)
  548. X  (let ((math-living-dangerously t))
  549. X    (math-simplify a))
  550. X)
  551. X
  552. X(defun math-simplify (top-expr)
  553. X  (calc-with-default-simplification
  554. X   (let ((math-simplify-symbolic-powers t)
  555. X     res)
  556. X     (while (not (equal top-expr (setq res (math-simplify-step
  557. X                        (math-normalize top-expr)))))
  558. X       (setq top-expr res))))
  559. X  top-expr
  560. X)
  561. X
  562. X;;; The following has a "bug" in that if any recursive simplifications
  563. X;;; occur only the first handler will be tried; this doesn't really
  564. X;;; matter, since math-simplify-step is iterated to a fixed point anyway.
  565. X(defun math-simplify-step (a)
  566. X  (if (Math-primp a)
  567. X      a
  568. X    (let ((aa (cons (car a) (mapcar 'math-simplify-step (cdr a)))))
  569. X      (and (symbolp (car aa))
  570. X       (let ((handler (get (car aa) 'math-simplify)))
  571. X         (and handler
  572. X          (progn
  573. X            (while (and handler
  574. X                (equal (setq aa (or (funcall (car handler) aa)
  575. X                            aa))
  576. X                       a))
  577. X              (setq handler (cdr handler)))
  578. X            res))))
  579. X      aa))
  580. X)
  581. X
  582. X(defmacro math-defsimplify (funcs &rest code)
  583. X  "Define a simplification rule for the specified function.
  584. XIf FUNCS is a list of functions, the same rule is applied for each function.
  585. XCODE is a body of Lisp code that returns a simpler form of EXPR.
  586. XMore than one definition may be made per function.  All definitions are tried
  587. Xin the order they were encountered; the first non-NIL value which is different
  588. Xfrom the original expression returned is used.  The argument EXPR may be
  589. Xdestructively modified."
  590. X  (append '(progn)
  591. X      (mapcar (function
  592. X           (lambda (func)
  593. X             (list 'put (list 'quote func) ''math-simplify
  594. X               (list 'nconc
  595. X                 (list 'get (list 'quote func) ''math-simplify)
  596. X                 (list 'list
  597. X                       (list 'function
  598. X                         (append '(lambda (expr))
  599. X                             code)))))))
  600. X          (if (symbolp funcs) (list funcs) funcs)))
  601. X)
  602. X(put 'math-defsimplify 'lisp-indent-hook 1)
  603. X
  604. X(math-defsimplify (+ -)
  605. X  (math-simplify-plus))
  606. X
  607. X(defun math-simplify-plus ()
  608. X  (cond ((and (memq (car-safe (nth 1 expr)) '(+ -))
  609. X          (Math-numberp (nth 2 (nth 1 expr)))
  610. X          (not (Math-numberp (nth 2 expr))))
  611. X     (let ((x (nth 2 expr))
  612. X           (op (car expr)))
  613. X       (setcar (cdr (cdr expr)) (nth 2 (nth 1 expr)))
  614. X       (setcar expr (car (nth 1 expr)))
  615. X       (setcar (cdr (cdr (nth 1 expr))) x)
  616. X       (setcar (nth 1 expr) op)))
  617. X    ((and (eq (car expr) '+)
  618. X          (Math-numberp (nth 1 expr))
  619. X          (not (Math-numberp (nth 2 expr))))
  620. X     (let ((x (nth 2 expr)))
  621. X       (setcar (cdr (cdr expr)) (nth 1 expr))
  622. X       (setcar (cdr expr) x))))
  623. X  (let ((aa expr)
  624. X    aaa temp)
  625. X    (while (memq (car-safe (setq aaa (nth 1 aa))) '(+ -))
  626. X      (if (setq temp (math-combine-sum (nth 2 aaa) (nth 2 expr)
  627. X                       (eq (car aaa) '-) (eq (car expr) '-) t))
  628. X      (progn
  629. X        (setcar (cdr (cdr expr)) temp)
  630. X        (setcar expr '+)
  631. X        (setcar (cdr (cdr aaa)) 0)))
  632. X      (setq aa (nth 1 aa)))
  633. X    (if (setq temp (math-combine-sum aaa (nth 2 expr)
  634. X                     nil (eq (car expr) '-) t))
  635. X    (progn
  636. X      (setcar (cdr (cdr expr)) temp)
  637. X      (setcar expr '+)
  638. X      (setcar (cdr aa) 0)))
  639. X    expr)
  640. X)
  641. X
  642. X(math-defsimplify *
  643. X  (math-simplify-times))
  644. X
  645. X(defun math-simplify-times ()
  646. X  (if (eq (car-safe (nth 2 expr)) '*)
  647. X      (and (math-beforep (nth 1 (nth 2 expr)) (nth 1 expr))
  648. X       (let ((x (nth 1 expr)))
  649. X         (setcar (cdr expr) (nth 1 (nth 2 expr)))
  650. X         (setcar (cdr (nth 2 expr)) x)))
  651. X    (and (math-beforep (nth 2 expr) (nth 1 expr))
  652. X     (let ((x (nth 2 expr)))
  653. X       (setcar (cdr (cdr expr)) (nth 1 expr))
  654. X       (setcar (cdr expr) x))))
  655. X  (let ((aa expr)
  656. X    aaa temp)
  657. X    (while (eq (car-safe (setq aaa (nth 2 aa))) '*)
  658. X      (if (setq temp (math-combine-prod (nth 1 expr) (nth 1 aaa) nil nil t))
  659. X      (progn
  660. X        (setcar (cdr expr) temp)
  661. X        (setcar (cdr aaa) 1)))
  662. X      (setq aa (nth 2 aa)))
  663. X    (if (setq temp (math-combine-prod aaa (nth 1 expr) nil nil t))
  664. X    (progn
  665. X      (setcar (cdr expr) temp)
  666. X      (setcar (cdr (cdr aa)) 1)))
  667. X    expr)
  668. X)
  669. X
  670. X(math-defsimplify /
  671. X  (math-simplify-divide))
  672. X
  673. X(defun math-simplify-divide ()
  674. X  (let ((np (cdr expr))
  675. X    n nn)
  676. X    (setq nn (math-common-constant-factor (nth 2 expr)))
  677. X    (if nn
  678. X    (progn
  679. X      (setq n (math-common-constant-factor (nth 1 expr)))
  680. X      (if (and (consp nn) (eq (nth 1 nn) 1) (not n))
  681. X          (progn
  682. X        (setcar (cdr expr) (math-mul (nth 1 expr) nn))
  683. X        (setcar (cdr (cdr expr))
  684. X            (math-cancel-common-factor (nth 2 expr) nn)))
  685. X        (if (and n (not (eq (setq n (math-frac-gcd n nn)) 1)))
  686. X        (progn
  687. X          (setcar (cdr expr)
  688. X              (math-cancel-common-factor (nth 1 expr) n))
  689. X          (setcar (cdr (cdr expr))
  690. X              (math-cancel-common-factor (nth 2 expr) n)))))))
  691. X    (while (eq (car-safe (setq n (car np))) '*)
  692. X      (math-simplify-divisor (cdr n) (cdr (cdr expr)))
  693. X      (setq np (cdr (cdr n))))
  694. X    (math-simplify-divisor np (cdr (cdr expr)))
  695. X    expr)
  696. X)
  697. X
  698. X(defun math-simplify-divisor (np dp)
  699. X  (let ((n (car np))
  700. X    d dd temp)
  701. X    (while (eq (car-safe (setq d (car dp))) '*)
  702. X      (if (setq temp (math-combine-prod n (nth 1 d) nil t t))
  703. X      (progn
  704. X        (setcar np (setq n temp))
  705. X        (setcar (cdr d) 1)))
  706. X      (setq dp (cdr (cdr d))))
  707. X    (if (setq temp (math-combine-prod n d nil t t))
  708. X    (progn
  709. X      (setcar np (setq n temp))
  710. X      (setcar dp 1))))
  711. X)
  712. X
  713. X(defun math-common-constant-factor (expr)
  714. X  (if (Math-primp expr)
  715. X      (if (Math-ratp expr)
  716. X      (and (not (memq expr '(0 1)))
  717. X           (math-abs expr))
  718. X    (if (Math-ratp (setq expr (math-to-simple-fraction expr)))
  719. X        (math-common-constant-factor expr)))
  720. X    (if (memq (car expr) '(+ -))
  721. X    (let ((f1 (math-common-constant-factor (nth 1 expr)))
  722. X          (f2 (math-common-constant-factor (nth 2 expr))))
  723. X      (and f1 f2
  724. X           (not (eq (setq f1 (math-frac-gcd f1 f2)) 1))
  725. X           f1))
  726. X      (if (memq (car expr) '(* /))
  727. X      (math-common-constant-factor (nth 1 expr)))))
  728. X)
  729. X
  730. X(defun math-cancel-common-factor (expr val)
  731. X  (if (memq (car-safe expr) '(+ -))
  732. X      (progn
  733. X    (setcar (cdr expr) (math-cancel-common-factor (nth 1 expr) val))
  734. X    (setcar (cdr (cdr expr)) (math-cancel-common-factor (nth 2 expr) val))
  735. X    expr)
  736. X    (math-div expr val))
  737. X)
  738. X
  739. X(defun math-frac-gcd (a b)
  740. X  (if (and (Math-integerp a)
  741. X       (Math-integerp b))
  742. X      (math-gcd a b)
  743. X    (or (Math-integerp a) (setq a (list 'frac a 1)))
  744. X    (or (Math-integerp b) (setq b (list 'frac b 1)))
  745. X    (math-make-frac (math-gcd (nth 1 a) (nth 1 b))
  746. X            (math-gcd (nth 2 a) (nth 2 b))))
  747. X)
  748. X
  749. X(math-defsimplify calcFunc-sin
  750. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
  751. X       (nth 1 (nth 1 expr)))
  752. X      (and (math-looks-negp (nth 1 expr))
  753. X       (math-neg (list 'calcFunc-sin (math-neg (nth 1 expr)))))
  754. X      (and math-living-dangerously
  755. X       (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
  756. X       (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))
  757. X      (and math-living-dangerously
  758. X       (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
  759. X       (math-div (nth 1 (nth 1 expr))
  760. X             (list 'calcFunc-sqrt
  761. X               (math-add 1 (math-sqr (nth 1 (nth 1 expr))))))))
  762. X)
  763. X
  764. X(math-defsimplify calcFunc-cos
  765. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
  766. X       (nth 1 (nth 1 expr)))
  767. X      (and (math-looks-negp (nth 1 expr))
  768. X       (list 'calcFunc-cos (math-neg (nth 1 expr))))
  769. X      (and math-living-dangerously
  770. X       (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
  771. X       (list 'calcFunc-sqrt (math-sub 1 (math-sqr (nth 1 (nth 1 expr))))))
  772. X      (and math-living-dangerously
  773. X       (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
  774. X       (math-div 1
  775. X             (list 'calcFunc-sqrt
  776. X               (math-add 1 (math-sqr (nth 1 (nth 1 expr))))))))
  777. X)
  778. X
  779. X(math-defsimplify calcFunc-tan
  780. X  (or (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctan)
  781. X       (nth 1 (nth 1 expr)))
  782. X      (and (math-looks-negp (nth 1 expr))
  783. X       (math-neg (list 'calcFunc-tan (math-neg (nth 1 expr)))))
  784. X      (and math-living-dangerously
  785. X       (eq (car-safe (nth 1 expr)) 'calcFunc-arcsin)
  786. X       (math-div (nth 1 (nth 1 expr))
  787. X             (list 'calcFunc-sqrt
  788. X               (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))))
  789. X      (and math-living-dangerously
  790. X       (eq (car-safe (nth 1 expr)) 'calcFunc-arccos)
  791. X       (math-div (list 'calcFunc-sqrt
  792. X               (math-sub 1 (math-sqr (nth 1 (nth 1 expr)))))
  793. X             (nth 1 (nth 1 expr)))))
  794. X)
  795. X
  796. X(math-defsimplify calcFunc-sinh
  797. X  (and (eq (car-safe (nth 1 expr)) 'calcFunc-arcsinh)
  798. X       (nth 1 (nth 1 expr)))
  799. X)
  800. X
  801. X(math-defsimplify calcFunc-cosh
  802. X  (and (eq (car-safe (nth 1 expr)) 'calcFunc-arccosh)
  803. X       (nth 1 (nth 1 expr)))
  804. X)
  805. X
  806. X(math-defsimplify calcFunc-tanh
  807. X  (and (eq (car-safe (nth 1 expr)) 'calcFunc-arctanh)
  808. X       (nth 1 (nth 1 expr)))
  809. X)
  810. X
  811. X(math-defsimplify calcFunc-arcsin
  812. X  (or (and (math-looks-negp (nth 1 expr))
  813. X       (math-neg (list 'calcFunc-arcsin (math-neg (nth 1 expr)))))
  814. X      (and math-living-dangerously
  815. X       (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
  816. X       (nth 1 (nth 1 expr)))
  817. X      (and math-living-dangerously
  818. X       (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
  819. X       (math-sub (math-div '(var pi var-pi) 2)
  820. X             (nth 1 (nth 1 expr)))))
  821. X)
  822. X
  823. X(math-defsimplify calcFunc-arccos
  824. X  (or (and math-living-dangerously
  825. X       (eq (car-safe (nth 1 expr)) 'calcFunc-cos)
  826. X       (nth 1 (nth 1 expr)))
  827. X      (and math-living-dangerously
  828. X       (eq (car-safe (nth 1 expr)) 'calcFunc-sin)
  829. X       (math-sub (math-div '(var pi var-pi) 2)
  830. X             (nth 1 (nth 1 expr)))))
  831. X)
  832. X
  833. X(math-defsimplify calcFunc-arctan
  834. X  (or (and (math-looks-negp (nth 1 expr))
  835. X       (math-neg (list 'calcFunc-arctan (math-neg (nth 1 expr)))))
  836. X      (and math-living-dangerously
  837. X       (eq (car-safe (nth 1 expr)) 'calcFunc-tan)
  838. X       (nth 1 (nth 1 expr))))
  839. X)
  840. X
  841. X(math-defsimplify calcFunc-arcsinh
  842. X  (and math-living-dangerously
  843. X       (eq (car-safe (nth 1 expr)) 'calcFunc-sinh)
  844. X       (nth 1 (nth 1 expr)))
  845. X)
  846. X
  847. X(math-defsimplify calcFunc-arccosh
  848. X  (and math-living-dangerously
  849. X       (eq (car-safe (nth 1 expr)) 'calcFunc-cosh)
  850. X       (nth 1 (nth 1 expr)))
  851. X)
  852. X
  853. X(math-defsimplify calcFunc-arctanh
  854. X  (and math-living-dangerously
  855. X       (eq (car-safe (nth 1 expr)) 'calcFunc-tanh)
  856. X       (nth 1 (nth 1 expr)))
  857. X)
  858. X
  859. X(math-defsimplify calcFunc-sqrt
  860. X  (or (let ((fac (math-common-constant-factor (nth 1 expr))))
  861. X    (and fac
  862. X         (math-mul (list 'calcFunc-sqrt fac)
  863. X               (list 'calcFunc-sqrt
  864. X                 (math-cancel-common-factor (nth 1 expr) fac)))))
  865. X      (and (eq (car-safe (nth 1 expr)) '-)
  866. X       (math-equal-int (nth 1 (nth 1 expr)) 1)
  867. X       (eq (car-safe (nth 2 (nth 1 expr))) '^)
  868. X       (math-equal-int (nth 2 (nth 2 (nth 1 expr))) 2)
  869. X       (or (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr)))) 'calcFunc-sin)
  870. X            (list 'calcFunc-cos
  871. X              (nth 1 (nth 1 (nth 2 (nth 1 expr))))))
  872. X           (and (eq (car-safe (nth 1 (nth 2 (nth 1 expr)))) 'calcFunc-cos)
  873. X            (list 'calcFunc-sin
  874. X              (nth 1 (nth 1 (nth 2 (nth 1 expr))))))))
  875. X      (and math-living-dangerously
  876. X       (or (and (eq (car-safe (nth 1 expr)) '^)
  877. X            (list '^
  878. X              (nth 1 (nth 1 expr))
  879. X              (math-div (nth 2 (nth 1 expr)) 2)))
  880. X           (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
  881. X            (list '^ (nth 1 (nth 1 expr)) (math-div 1 4))))))
  882. X)
  883. X
  884. X(math-defsimplify 'calcFunc-exp
  885. X  (and (eq (car-safe (nth 1 expr)) 'calcFunc-ln)
  886. X       (nth 1 (nth 1 expr)))
  887. X)
  888. X
  889. X(math-defsimplify 'calcFunc-ln
  890. X  (and math-living-dangerously
  891. X       (eq (car-safe (nth 1 expr)) 'calcFunc-exp)
  892. X       (nth 1 (nth 1 expr)))
  893. X)
  894. X
  895. X(math-defsimplify '^
  896. X  (math-simplify-pow))
  897. X
  898. X(defun math-simplify-pow ()
  899. X  (or (and math-living-dangerously
  900. X       (or (and (eq (car-safe (nth 1 expr)) '^)
  901. X            (list '^
  902. X              (nth 1 (nth 1 expr))
  903. X              (math-mul (nth 2 expr) (nth 2 (nth 1 expr)))))
  904. X           (and (eq (car-safe (nth 1 expr)) 'calcFunc-sqrt)
  905. X            (list '^
  906. X              (nth 1 (nth 1 expr))
  907. X              (math-div (nth 2 expr) 2)))))
  908. X      (and (math-equal-int (nth 1 expr) 10)
  909. X       (eq (car-safe (nth 2 expr)) 'calcFunc-log10)
  910. X       (nth 1 (nth 2 expr)))
  911. X      (and (equal (nth 1 expr) '(var e var-e))
  912. X       (eq (car-safe (nth 2 expr)) 'calcFunc-ln)
  913. X       (nth 1 (nth 2 expr))))
  914. X)
  915. X
  916. X(math-defsimplify 'calcFunc-log10
  917. X  (and math-living-dangerously
  918. X       (eq (car-safe (nth 1 expr)) '^)
  919. X       (math-equal-int (nth 1 (nth 1 expr)) 10)
  920. X       (nth 2 (nth 1 expr)))
  921. X)
  922. X
  923. X
  924. X
  925. X
  926. X(defun math-expand-term (expr)
  927. X  (cond ((and (eq (car-safe expr) '*)
  928. X          (memq (car-safe (nth 1 expr)) '(+ -)))
  929. X     (math-add-or-sub (math-mul (nth 1 (nth 1 expr)) (nth 2 expr))
  930. X              (math-mul (nth 2 (nth 1 expr)) (nth 2 expr))
  931. X              nil (eq (car (nth 1 expr)) '-)))
  932. X    ((and (eq (car-safe expr) '*)
  933. X          (memq (car-safe (nth 2 expr)) '(+ -)))
  934. X     (math-add-or-sub (math-mul (nth 1 expr) (nth 1 (nth 2 expr)))
  935. X              (math-mul (nth 1 expr) (nth 2 (nth 2 expr)))
  936. X              nil (eq (car (nth 2 expr)) '-)))
  937. X    ((and (eq (car-safe expr) '/)
  938. X          (memq (car-safe (nth 1 expr)) '(+ -)))
  939. X     (math-add-or-sub (math-div (nth 1 (nth 1 expr)) (nth 2 expr))
  940. X              (math-div (nth 2 (nth 1 expr)) (nth 2 expr))
  941. X              nil (eq (car (nth 1 expr)) '-)))
  942. X    ((and (eq (car-safe expr) '^)
  943. X          (memq (car-safe (nth 1 expr)) '(+ -))
  944. X          (integerp (nth 2 expr))
  945. X          (if (> (nth 2 expr) 0)
  946. X          (list '*
  947. X            (nth 1 expr)
  948. X            (math-pow (nth 1 expr) (1- (nth 2 expr))))
  949. X        (if (< (nth 2 expr) 0)
  950. X            (math-div 1 (math-pow (nth 1 expr)
  951. X                      (- (nth 2 expr))))))))
  952. X    (t expr))
  953. X)
  954. X
  955. X(defun math-expand-tree (expr &optional many)
  956. X  (math-map-tree 'math-expand-term expr many)
  957. X)
  958. X
  959. X(defun math-map-tree (mmt-func mmt-expr &optional mmt-many)
  960. X  (or mmt-many (setq mmt-many 1000000))
  961. X  (math-map-tree-rec mmt-expr)
  962. X)
  963. X
  964. X(defun math-map-tree-rec (mmt-expr)
  965. X  (or (= mmt-many 0)
  966. X      (let ((mmt-done nil)
  967. X        mmt-nextval)
  968. X    (while (not mmt-done)
  969. X      (while (and (/= mmt-many 0)
  970. X              (setq mmt-nextval (funcall mmt-func mmt-expr))
  971. X              (not (equal mmt-expr mmt-nextval)))
  972. X        (setq mmt-expr mmt-nextval
  973. X          mmt-many (if (> mmt-many 0) (1- mmt-many) (1+ mmt-many))))
  974. X      (if (or (Math-primp mmt-expr)
  975. X          (<= mmt-many 0))
  976. X          (setq mmt-done t)
  977. X        (setq mmt-nextval (cons (car mmt-expr)
  978. X                (mapcar 'math-map-tree-rec (cdr mmt-expr))))
  979. X        (if (equal mmt-nextval mmt-expr)
  980. X        (setq mmt-done t)
  981. X          (setq mmt-expr mmt-nextval))))))
  982. X  mmt-expr
  983. X)
  984. X
  985. X
  986. X
  987. X
  988. X(defun math-apply-rewrite (expr lhs rhs &optional cond)
  989. X  (let ((matches-found nil))
  990. X    (and (math-match-pattern expr lhs)
  991. X     (or (null cond)
  992. X         (math-is-true (math-simplify (math-replace-variables cond))))
  993. X     (math-replace-variables rhs)))
  994. X)
  995. X
  996. X(defun math-apply-rewrite-rules (expr rules)
  997. X  (let ((r rules)
  998. X    next)
  999. X    (while (and r
  1000. X        (or (not (setq next (math-apply-rewrite expr
  1001. X                            (nth 1 (car r))
  1002. X                            (nth 2 (car r))
  1003. X                            (nth 3 (car r)))))
  1004. X            (equal expr (setq next (math-normalize next)))))
  1005. X      (setq r (cdr r)))
  1006. X    (and r
  1007. X     next))
  1008. X)
  1009. X
  1010. X(defun math-rewrite (expr rules &optional many)
  1011. X  (setq rules (math-check-rewrite-rules rules))
  1012. X  (math-map-tree (function (lambda (x) (math-apply-rewrite-rules x rules)))
  1013. X         expr many)
  1014. X)
  1015. X
  1016. X(defun math-check-rewrite-rules (rules)
  1017. X  (if (and (eq (car-safe rules) 'var)
  1018. X       (boundp (nth 2 rules))
  1019. X       (symbol-value (nth 2 rules)))
  1020. X      (setq rules (symbol-value (nth 2 rules))))
  1021. X  (or (Math-vectorp rules)
  1022. X      (error "Rules must be a vector"))
  1023. X  (setq rules (if (Math-vectorp (nth 1 rules))
  1024. X          (cdr rules)
  1025. X        (list rules)))
  1026. X  (let ((r rules))
  1027. X    (while r
  1028. X      (or (and (Math-vectorp (car r))
  1029. X           (cdr (cdr (car r)))
  1030. X           (not (nthcdr 4 (car r))))
  1031. X      (error "Malformed rules vector"))
  1032. X      (setq r (cdr r))))
  1033. X  rules
  1034. X)
  1035. X
  1036. X(defun math-match-pattern (expr pat)
  1037. X  (cond ((Math-primp pat)
  1038. X     (or (math-equal expr pat)
  1039. X         (and (eq (car-safe pat) 'var)
  1040. X          (let ((match (assq (nth 1 pat) matches-found)))
  1041. X            (if match
  1042. X            (equal expr (nth 1 match))
  1043. X              (setq matches-found (cons (list (nth 1 pat)
  1044. X                              expr)
  1045. X                        matches-found)))))))
  1046. X    ((eq (car pat) 'calcFunc-quote)
  1047. X     (equal expr (nth 1 pat)))
  1048. X    (t
  1049. X     (and (eq (car pat) (car-safe expr))
  1050. X          (progn
  1051. X        (while (and (setq expr (cdr expr) pat (cdr pat))
  1052. X                expr
  1053. X                (math-match-pattern (car expr) (car pat))))
  1054. X        (and (null expr) (null pat))))))
  1055. X)
  1056. X
  1057. X(defun math-replace-variables (expr)
  1058. X  (if (Math-primp expr)
  1059. X      (if (eq (car-safe expr) 'var)
  1060. X      (let ((match (assq (nth 1 expr) matches-found)))
  1061. X        (if match
  1062. X        (nth 1 match)
  1063. X          expr))
  1064. X    expr)
  1065. X    (cons (car expr) (mapcar 'math-replace-variables (cdr expr))))
  1066. X)
  1067. X
  1068. X(defun math-is-true (expr)
  1069. X  (and (Math-realp expr)
  1070. X       (not (Math-zerop expr)))
  1071. X)
  1072. X
  1073. X
  1074. X
  1075. X
  1076. X(defun math-derivative (expr)   ; uses global values: deriv-var, deriv-total.
  1077. X  (cond ((equal expr deriv-var)
  1078. X     1)
  1079. X    ((or (Math-scalarp expr)
  1080. X         (eq (car expr) 'sdev)
  1081. X         (and (eq (car expr) 'var)
  1082. X          (not deriv-total)))
  1083. X     0)
  1084. X    ((eq (car expr) '+)
  1085. X     (math-add (math-derivative (nth 1 expr))
  1086. X           (math-derivative (nth 2 expr))))
  1087. X    ((eq (car expr) '-)
  1088. X     (math-sub (math-derivative (nth 1 expr))
  1089. X           (math-derivative (nth 2 expr))))
  1090. X    ((eq (car expr) 'neg)
  1091. X     (math-neg (math-derivative (nth 1 expr))))
  1092. X    ((eq (car expr) '*)
  1093. X     (math-add (math-mul (nth 2 expr)
  1094. X                 (math-derivative (nth 1 expr)))
  1095. X           (math-mul (nth 1 expr)
  1096. X                 (math-derivative (nth 2 expr)))))
  1097. X    ((eq (car expr) '/)
  1098. X     (math-sub (math-div (math-derivative (nth 1 expr))
  1099. X                 (nth 2 expr))
  1100. X           (math-div (math-mul (nth 1 expr)
  1101. X                       (math-derivative (nth 2 expr)))
  1102. X                 (math-sqr (nth 2 expr)))))
  1103. X    ((eq (car expr) '^)
  1104. X     (let ((du (math-derivative (nth 1 expr)))
  1105. X           (dv (math-derivative (nth 2 expr))))
  1106. X       (or (Math-zerop du)
  1107. X           (setq du (math-mul (nth 2 expr)
  1108. X                  (math-mul (math-normalize
  1109. X                         (list '^
  1110. X                           (nth 1 expr)
  1111. X                           (math-add (nth 2 expr) -1)))
  1112. X                        du))))
  1113. X       (or (Math-zerop dv)
  1114. X           (setq dv (math-mul (math-normalize
  1115. X                   (list 'calcFunc-ln (nth 1 expr)))
  1116. X                  (math-mul expr dv))))
  1117. X       (math-add du dv)))
  1118. X    ((eq (car expr) '%)
  1119. X     (math-derivative (nth 1 expr)))   ; a reasonable definition
  1120. X    ((eq (car expr) 'vec)
  1121. X     (math-map-vec 'math-derivative expr))
  1122. X    ((and (eq (car expr) 'calcFunc-log)
  1123. X          (= (length expr) 3)
  1124. X          (not (Math-zerop (nth 2 expr))))
  1125. X     (let ((lnv (math-normalize (list 'calcFunc-ln (nth 2 expr)))))
  1126. X       (math-sub (math-div (math-derivative (nth 1 expr))
  1127. X                   (math-mul lnv (nth 1 expr)))
  1128. X             (math-div (math-derivative (nth 2 expr))
  1129. X                   (math-mul (math-sqr lnv)
  1130. X                     (nth 2 expr))))))
  1131. X    (t (or (and (= (length expr) 2)
  1132. X            (symbolp (car expr))
  1133. X            (let ((handler (get (car expr) 'math-derivative)))
  1134. X              (and handler
  1135. X               (let ((deriv (math-derivative (nth 1 expr))))
  1136. X                 (if (Math-zerop deriv)
  1137. X                 deriv
  1138. X                   (math-mul (funcall handler (nth 1 expr))
  1139. X                     deriv))))))
  1140. X           (if deriv-symb
  1141. X           (throw 'math-deriv nil)
  1142. X         (if (or (Math-objvecp expr)
  1143. X             (not (symbolp (car expr))))
  1144. X             (list (if deriv-total 'calcFunc-tderiv 'calcFunc-deriv)
  1145. X               expr
  1146. X               deriv-var)
  1147. X           (let ((accum 0)
  1148. X             (arg expr)
  1149. X             (n 1)
  1150. X             derv)
  1151. X             (while (setq arg (cdr arg))
  1152. X               (or (Math-zerop (setq derv (math-derivative (car arg))))
  1153. X               (let ((func (intern (concat (symbol-name (car expr))
  1154. X                               "'"
  1155. X                               (if (> n 1)
  1156. X                               (int-to-string n)
  1157. X                             "")))))
  1158. X                 (setq accum (math-add
  1159. X                      accum
  1160. X                      (math-mul derv
  1161. X                            (cons func
  1162. X                              (cdr expr)))))))
  1163. X               (setq n (1+ n)))
  1164. X             accum))))))
  1165. X)
  1166. X
  1167. X(defun calcFunc-deriv (expr deriv-var &optional deriv-value deriv-symb)
  1168. X  (let* ((deriv-total nil)
  1169. X     (res (catch 'math-deriv (math-derivative expr))))
  1170. X    (or (eq (car-safe res) 'calcFunc-deriv)
  1171. X    (null res)
  1172. X    (setq res (math-normalize res)))
  1173. X    (and res
  1174. X     (if deriv-value
  1175. X         (math-expr-subst res deriv-var deriv-value)
  1176. X       res)))
  1177. X)
  1178. X
  1179. X(defun calcFunc-tderiv (expr deriv-var &optional deriv-value deriv-symb)
  1180. X  (let* ((deriv-total t)
  1181. X     (res (catch 'math-deriv (math-derivative expr))))
  1182. X    (or (eq (car-safe res) 'calcFunc-tderiv)
  1183. X    (null res)
  1184. X    (setq res (math-normalize res)))
  1185. X    (and res
  1186. X     (if deriv-value
  1187. X         (math-expr-subst res deriv-var deriv-value)
  1188. X       res)))
  1189. X)
  1190. X
  1191. X(put 'calcFunc-inv 'math-derivative
  1192. X     (function (lambda (u) (math-neg (math-div 1 (math-sqr u))))))
  1193. X
  1194. X(put 'calcFunc-sqrt 'math-derivative
  1195. X     (function (lambda (u) (math-div 1 (math-mul 2 (list 'calcFunc-sqrt u))))))
  1196. X
  1197. X(put 'calcFunc-conj 'math-derivative
  1198. X     (function (lambda (u) (math-normalize (list 'calcFunc-conj u)))))
  1199. X
  1200. X(put 'calcFunc-deg 'math-derivative
  1201. X     (function (lambda (u) (math-div (math-pi-over-180) u))))
  1202. X
  1203. X(put 'calcFunc-rad 'math-derivative
  1204. X     (function (lambda (u) (math-mul (math-pi-over-180) u))))
  1205. X
  1206. X(put 'calcFunc-ln 'math-derivative
  1207. X     (function (lambda (u) (math-div 1 u))))
  1208. X
  1209. X(put 'calcFunc-log10 'math-derivative
  1210. X     (function (lambda (u)
  1211. X         (math-div (math-div 1 (math-normalize '(calcFunc-ln 10)))
  1212. X               u))))
  1213. X
  1214. X(put 'calcFunc-lnp1 'math-derivative
  1215. X     (function (lambda (u) (math-div 1 (math-add u 1)))))
  1216. X
  1217. X(put 'calcFunc-exp 'math-derivative
  1218. X     (function (lambda (u) (math-normalize (list 'calcFunc-exp u)))))
  1219. X
  1220. X(put 'calcFunc-expm1 'math-derivative
  1221. X     (function (lambda (u) (math-normalize (list 'calcFunc-expm1 u)))))
  1222. X
  1223. X(put 'calcFunc-sin 'math-derivative
  1224. X     (function (lambda (u) (math-to-radians-2 (math-normalize
  1225. X                           (list 'calcFunc-cos u))))))
  1226. X
  1227. X(put 'calcFunc-cos 'math-derivative
  1228. X     (function (lambda (u) (math-neg (math-to-radians-2
  1229. X                      (math-normalize
  1230. X                       (list 'calcFunc-sin u)))))))
  1231. X
  1232. X(put 'calcFunc-tan 'math-derivative
  1233. X     (function (lambda (u) (math-to-radians-2
  1234. X                (math-div 1 (math-sqr
  1235. X                     (math-normalize
  1236. X                      (list 'calcFunc-cos u))))))))
  1237. X
  1238. X(put 'calcFunc-arcsin 'math-derivative
  1239. X     (function (lambda (u)
  1240. X         (math-from-radians-2
  1241. X          (math-div 1 (math-normalize
  1242. X                   (list 'calcFunc-sqrt
  1243. X                     (math-sub 1 (math-sqr u)))))))))
  1244. X
  1245. X(put 'calcFunc-arccos 'math-derivative
  1246. X     (function (lambda (u)
  1247. X         (math-from-radians-2
  1248. X          (math-div -1 (math-normalize
  1249. X                (list 'calcFunc-sqrt
  1250. X                      (math-sub 1 (math-sqr u)))))))))
  1251. X
  1252. X(put 'calcFunc-arctan 'math-derivative
  1253. X     (function (lambda (u) (math-from-radians-2
  1254. X                (math-div 1 (math-add 1 (math-sqr u)))))))
  1255. X
  1256. X(put 'calcFunc-sinh 'math-derivative
  1257. X     (function (lambda (u) (math-normalize (list 'calcFunc-cosh u)))))
  1258. X
  1259. X(put 'calcFunc-cosh 'math-derivative
  1260. X     (function (lambda (u) (math-normalize (list 'calcFunc-sinh u)))))
  1261. X
  1262. X(put 'calcFunc-tanh 'math-derivative
  1263. X     (function (lambda (u) (math-div 1 (math-sqr
  1264. X                    (math-normalize
  1265. X                     (list 'calcFunc-cosh u)))))))
  1266. X
  1267. X(put 'calcFunc-arcsinh 'math-derivative
  1268. X     (function (lambda (u)
  1269. X         (math-div 1 (math-normalize
  1270. X                  (list 'calcFunc-sqrt
  1271. X                    (math-add (math-sqr u) 1)))))))
  1272. X
  1273. X(put 'calcFunc-arccosh 'math-derivative
  1274. X     (function (lambda (u)
  1275. X          (math-div 1 (math-normalize
  1276. X                   (list 'calcFunc-sqrt
  1277. X                     (math-add (math-sqr u) -1)))))))
  1278. X
  1279. X(put 'calcFunc-arctanh 'math-derivative
  1280. X     (function (lambda (u) (math-div 1 (math-sub 1 (math-sqr u))))))
  1281. X
  1282. X
  1283. X
  1284. X(setq math-integ-var '(var X ---))
  1285. X(setq math-integ-var-2 '(var Y ---))
  1286. X(setq math-integ-vars (list 'f math-integ-var math-integ-var-2))
  1287. X
  1288. X(defmacro math-tracing-integral (&rest parts)
  1289. X  (list 'and
  1290. X    'trace-buffer
  1291. X    (list 'save-excursion
  1292. X          '(set-buffer trace-buffer)
  1293. X          '(goto-char (point-max))
  1294. X          (list 'and
  1295. X            '(bolp)
  1296. X            '(insert (make-string (- calc-integral-limit
  1297. X                         math-integ-level) 32)
  1298. X                 (format "%2d " math-integ-depth)
  1299. X                 (make-string math-integ-level 32)))
  1300. X          (cons 'insert parts)
  1301. X          '(sit-for 0)))
  1302. X)
  1303. X
  1304. X;;; The following wrapper caches results and avoids infinite recursion.
  1305. X;;; Each cache entry is: ( A B )          Integral of A is B;
  1306. X;;;             ( A N )          Integral of A failed at level N;
  1307. X;;;             ( A busy )      Currently working on integral of A;
  1308. X;;;             ( A parts )      Currently working, integ-by-parts;
  1309. X;;;             ( A parts2 )      Currently working, integ-by-parts;
  1310. X;;;             ( A cancelled )  Ignore this cache entry;
  1311. X;;;             ( A [B] )        Same result as for cur-record = B.
  1312. X(defun math-integral (expr &optional simplify same-as-above)
  1313. X  (let* ((simp cur-record)
  1314. X     (cur-record (assoc expr math-integral-cache))
  1315. X     (math-integ-depth (1+ math-integ-depth))
  1316. X     (val 'cancelled))
  1317. X    (math-tracing-integral "Integrating "
  1318. X               (math-format-value expr 1000)
  1319. X               "...\n")
  1320. X    (and cur-record
  1321. X     (progn
  1322. X       (math-tracing-integral "Found "
  1323. X                  (math-format-value (nth 1 cur-record) 1000))
  1324. X       (and (consp (nth 1 cur-record))
  1325. X        (math-replace-integral-parts cur-record))
  1326. X       (math-tracing-integral " => "
  1327. X                  (math-format-value (nth 1 cur-record) 1000)
  1328. X                  "\n")))
  1329. X    (or (and cur-record
  1330. X         (not (eq (nth 1 cur-record) 'cancelled))
  1331. X         (or (not (integerp (nth 1 cur-record)))
  1332. X         (>= (nth 1 cur-record) math-integ-level)))
  1333. X    (and (consp expr)
  1334. X         (eq (car expr) 'var)
  1335. X         (eq (nth 1 expr) 'PARTS)
  1336. X         (listp (nth 2 expr))
  1337. X         (progn
  1338. X           (setq val nil)
  1339. X           t))
  1340. X    (unwind-protect
  1341. X        (progn
  1342. X          (let (math-integ-msg)
  1343. X        (if (eq calc-display-working-message 'lots)
  1344. X            (progn
  1345. X              (calc-set-command-flag 'clear-message)
  1346. X              (setq math-integ-msg (format
  1347. X                        "Working... Integrating %s"
  1348. X                        (math-format-flat-expr expr 0)))
  1349. X              (message math-integ-msg)))
  1350. X        (if cur-record
  1351. X            (setcar (cdr cur-record)
  1352. X                (if same-as-above (vector simp) 'busy))
  1353. X          (setq cur-record
  1354. X            (list expr (if same-as-above (vector simp) 'busy))
  1355. X            math-integral-cache (cons cur-record
  1356. X                          math-integral-cache)))
  1357. X        (if (eq simplify 'yes)
  1358. X            (progn
  1359. X              (math-tracing-integral "Simplifying...")
  1360. X              (setq simp (math-simplify expr))
  1361. X              (setq val (if (equal simp expr)
  1362. X                    (progn
  1363. X                      (math-tracing-integral " no change\n")
  1364. X                      (math-do-integral expr))
  1365. X                  (math-tracing-integral " simplified\n")
  1366. X                  (math-integral simp 'no t))))
  1367. X          (or (setq val (math-do-integral expr))
  1368. X              (eq simplify 'no)
  1369. X              (let ((simp (math-simplify expr)))
  1370. X            (or (equal simp expr)
  1371. X                (progn
  1372. X                  (math-tracing-integral "Trying again after "
  1373. X                             "simplification...\n")
  1374. X                  (setq val (math-integral simp 'no t))))))))
  1375. X          (if (eq calc-display-working-message 'lots)
  1376. X          (message math-integ-msg)))
  1377. X      (setcar (cdr cur-record) (or val math-integ-level))))
  1378. X    (setq val cur-record)
  1379. X    (while (vectorp (nth 1 val))
  1380. X      (setq val (aref (nth 1 val) 0)))
  1381. X    (setq val (if (memq (nth 1 val) '(parts parts2))
  1382. X          (progn
  1383. X            (setcar (cdr val) 'parts2)
  1384. X            (list 'var 'PARTS val))
  1385. X        (and (not (eq (nth 1 val) 'busy))
  1386. X             (not (integerp (nth 1 val)))
  1387. X             (nth 1 val))))
  1388. X    (math-tracing-integral "Integral of "
  1389. X               (math-format-value expr 1000)
  1390. X               "  is  "
  1391. X               (math-format-value val 1000)
  1392. X               "\n")
  1393. X    val)
  1394. X)
  1395. X(defvar math-integral-cache nil)
  1396. X(defvar math-integral-cache-state nil)
  1397. X
  1398. X(defun math-replace-integral-parts (expr)
  1399. X  (or (Math-primp expr)
  1400. X      (while (setq expr (cdr expr))
  1401. X    (and (consp (car expr))
  1402. X         (if (eq (car (car expr)) 'var)
  1403. X         (and (eq (nth 1 (car expr)) 'PARTS)
  1404. X              (consp (nth 2 (car expr)))
  1405. X              (if (listp (nth 1 (nth 2 (car expr))))
  1406. X              (progn
  1407. X                (setcar expr (nth 1 (nth 2 (car expr))))
  1408. X                (math-replace-integral-parts (cons 'foo expr)))
  1409. X            (setcar (cdr cur-record) 'cancelled)))
  1410. X           (math-replace-integral-parts (car expr))))))
  1411. X)
  1412. X
  1413. X(defun math-do-integral (expr)
  1414. X  (let (t1 t2)
  1415. X    (or (cond ((not (math-expr-contains expr math-integ-var))
  1416. X           (math-mul expr math-integ-var))
  1417. X          ((equal expr math-integ-var)
  1418. X           (math-div (math-sqr expr) 2))
  1419. X          ((eq (car expr) '+)
  1420. X           (and (setq t1 (math-integral (nth 1 expr)))
  1421. X            (setq t2 (math-integral (nth 2 expr)))
  1422. X            (math-add t1 t2)))
  1423. X          ((eq (car expr) '-)
  1424. X           (and (setq t1 (math-integral (nth 1 expr)))
  1425. X            (setq t2 (math-integral (nth 2 expr)))
  1426. X            (math-sub t1 t2)))
  1427. X          ((eq (car expr) 'neg)
  1428. X           (and (setq t1 (math-integral (nth 1 expr)))
  1429. X            (math-neg t1)))
  1430. X          ((eq (car expr) '*)
  1431. X           (cond ((not (math-expr-contains (nth 1 expr) math-integ-var))
  1432. X              (and (setq t1 (math-integral (nth 2 expr)))
  1433. X               (math-mul (nth 1 expr) t1)))
  1434. X             ((not (math-expr-contains (nth 2 expr) math-integ-var))
  1435. X              (and (setq t1 (math-integral (nth 1 expr)))
  1436. X               (math-mul t1 (nth 2 expr))))
  1437. X             ((memq (car-safe (nth 1 expr)) '(+ -))
  1438. X              (math-integral (list (car (nth 1 expr))
  1439. X                       (math-mul (nth 1 (nth 1 expr))
  1440. X                             (nth 2 expr))
  1441. X                       (math-mul (nth 2 (nth 1 expr))
  1442. X                             (nth 2 expr)))
  1443. X                     'yes t))
  1444. X             ((memq (car-safe (nth 2 expr)) '(+ -))
  1445. X              (math-integral (list (car (nth 2 expr))
  1446. X                       (math-mul (nth 1 (nth 2 expr))
  1447. X                             (nth 1 expr))
  1448. X                       (math-mul (nth 2 (nth 2 expr))
  1449. X                             (nth 1 expr)))
  1450. X                     'yes t))))
  1451. X          ((eq (car expr) '/)
  1452. X           (cond ((not (math-expr-contains (nth 2 expr) math-integ-var))
  1453. X              (and (setq t1 (math-integral (nth 1 expr)))
  1454. X               (math-div t1 (nth 2 expr))))
  1455. X             ((and (eq (car-safe (nth 1 expr)) '*)
  1456. X               (not (math-expr-contains (nth 1 (nth 1 expr))
  1457. X                            math-integ-var)))
  1458. X              (and (setq t1 (math-integral
  1459. X                     (math-div (nth 2 (nth 1 expr))
  1460. X                           (nth 2 expr))))
  1461. X               (math-mul t1 (nth 1 (nth 1 expr)))))
  1462. X             ((and (eq (car-safe (nth 2 expr)) '*)
  1463. X               (not (math-expr-contains (nth 1 (nth 2 expr))
  1464. X                            math-integ-var)))
  1465. X              (and (setq t1 (math-integral
  1466. X                     (math-div (nth 1 expr)
  1467. X                           (nth 2 (nth 2 expr)))))
  1468. X               (math-div t1 (nth 1 (nth 2 expr)))))
  1469. X             ((memq (car-safe (nth 1 expr)) '(+ -))
  1470. X              (math-integral (list (car (nth 1 expr))
  1471. X                       (math-div (nth 1 (nth 1 expr))
  1472. X                             (nth 2 expr))
  1473. X                       (math-div (nth 2 (nth 1 expr))
  1474. X                             (nth 2 expr)))
  1475. X                     'yes t))))
  1476. X          ((eq (car expr) '^)
  1477. X           (cond ((not (math-expr-contains (nth 1 expr) math-integ-var))
  1478. X              (or (and (setq t1 (math-is-polynomial (nth 2 expr)
  1479. X                                math-integ-var 1))
  1480. X                   (math-div expr
  1481. X                     (math-mul (nth 1 t1)
  1482. X                           (math-normalize
  1483. X                            (list 'calcFunc-ln
  1484. X                              (nth 1 expr))))))
  1485. X              (math-integral
  1486. X               (list 'calcFunc-exp
  1487. X                 (math-mul (nth 2 expr)
  1488. X                       (math-normalize
  1489. X                        (list 'calcFunc-ln
  1490. X                          (nth 1 expr)))))
  1491. X               'yes t)))
  1492. X             ((not (math-expr-contains (nth 2 expr) math-integ-var))
  1493. X              (if (Math-equal-int (nth 2 expr) -1)
  1494. X              (math-integral (math-div 1 (nth 1 expr)) nil t)
  1495. X            (or (and (setq t1 (math-is-polynomial (nth 1 expr)
  1496. X                                  math-integ-var
  1497. X                                  1))
  1498. X                 (setq t2 (math-add (nth 2 expr) 1))
  1499. X                 (math-div (math-pow (nth 1 expr) t2)
  1500. X                       (math-mul t2 (nth 1 t1))))
  1501. X                (and (Math-negp (nth 2 expr))
  1502. X                 (math-integral
  1503. X                  (math-div 1
  1504. X                        (math-pow (nth 1 expr)
  1505. X                              (math-neg
  1506. X                               (nth 2 expr))))
  1507. X                  nil t))
  1508. X                nil))))))
  1509. X
  1510. X    ;; Integral of a polynomial.
  1511. X    (and (setq t1 (math-is-polynomial expr math-integ-var 20))
  1512. X         (let ((accum 0)
  1513. X           (n 1))
  1514. X           (while t1
  1515. X         (if (setq accum (math-add accum
  1516. X                       (math-div (math-mul (car t1)
  1517. X                                   (math-pow
  1518. X                                math-integ-var
  1519. X                                n))
  1520. X                             n))
  1521. X               t1 (cdr t1))
  1522. X             (setq n (1+ n))))
  1523. X           accum))
  1524. X
  1525. X    ;; Try looking it up!
  1526. X    (cond ((= (length expr) 2)
  1527. X           (and (symbolp (car expr))
  1528. X            (setq t1 (get (car expr) 'math-integral))
  1529. X            (progn
  1530. X              (while (and t1
  1531. X                  (not (setq t2 (funcall (car t1)
  1532. X                             (nth 1 expr)))))
  1533. X            (setq t1 (cdr t1)))
  1534. X              (and t2 (math-normalize t2)))))
  1535. X          ((= (length expr) 3)
  1536. X           (and (symbolp (car expr))
  1537. X            (setq t1 (get (car expr) 'math-integral-2))
  1538. X            (progn
  1539. X              (while (and t1
  1540. X                  (not (setq t2 (funcall (car t1)
  1541. X                             (nth 1 expr)
  1542. X                             (nth 2 expr)))))
  1543. X            (setq t1 (cdr t1)))
  1544. X              (and t2 (math-normalize t2))))))
  1545. X
  1546. X    ;; Integration by substitution, for various likely sub-expressions.
  1547. X    ;; (We should also try some of the classic non-obvious substitutions.)
  1548. X    (let ((so-far nil))
  1549. X      (math-integ-try-substitutions expr))
  1550. X
  1551. X    ;; Integration by parts:
  1552. X    ;;   integ(f(x) g(x),x) = f(x) h(x) - integ(h(x) f'(x),x)
  1553. X    ;;     where h(x) = integ(g(x),x).
  1554. X    (and (eq (car expr) '*)
  1555. X         (not (math-polynomial-p (nth 2 expr) math-integ-var))
  1556. X         (math-integrate-by-parts (nth 1 expr) (nth 2 expr)))
  1557. X    (and (eq (car expr) '/)
  1558. X         (math-expr-contains (nth 1 expr) math-integ-var)
  1559. X         (let ((recip (math-div 1 (nth 2 expr))))
  1560. X           (or (math-integrate-by-parts (nth 1 expr) recip)
  1561. X           (math-integrate-by-parts recip (nth 1 expr)))))
  1562. X    (and (eq (car expr) '^)
  1563. X         (math-integrate-by-parts (nth 1 expr)
  1564. X                      (math-pow (nth 1 expr)
  1565. X                        (math-sub (nth 2 expr) 1))))
  1566. X
  1567. X    ;; Symmetries.
  1568. X    (and (eq (car expr) '*)
  1569. X         (math-integral (list '* (nth 2 expr) (nth 1 expr)) 'no t))
  1570. X
  1571. X    ;; Give up.
  1572. X    nil))
  1573. X)
  1574. X
  1575. X(defun math-integrate-by-parts (u vprime)
  1576. X  (and (> math-integ-level 0)
  1577. X       (not (boundp 'math-disable-parts))
  1578. X       (let ((math-integ-level (1- math-integ-level))
  1579. X         v temp)
  1580. X     (unwind-protect
  1581. X         (progn
  1582. X           (setcar (cdr cur-record) 'parts)
  1583. X           (math-tracing-integral "Integrating by parts, u = "
  1584. X                      (math-format-value u 1000)
  1585. X                      ", v' = "
  1586. X                      (math-format-value vprime 1000)
  1587. X                      "\n")
  1588. X           (and (setq v (math-integral vprime))
  1589. X            (setq temp (calcFunc-deriv u
  1590. X                           math-integ-var
  1591. X                           nil t))
  1592. X            (setq temp (math-integral (math-mul v temp) 'yes))
  1593. X            (setq temp (math-sub (math-mul u v) temp))
  1594. X            (if (eq (nth 1 cur-record) 'parts)
  1595. X            temp
  1596. X              (setq v (list 'var 'PARTS cur-record)
  1597. X                temp (math-solve-for (math-sub v temp) 0 v nil))
  1598. X              (and temp (math-simplify-extended temp)))))
  1599. X       (setcar (cdr cur-record) 'busy))))
  1600. X)
  1601. X
  1602. X;;; This tries two different formulations, hoping the algebraic simplifier
  1603. X;;; will be strong enough to handle at least one.
  1604. X(defun math-integrate-by-substitution (expr u)
  1605. X  (and (> math-integ-level 0)
  1606. X       (let ((math-integ-level (1- math-integ-level))
  1607. X         (math-living-dangerously t)
  1608. X         uinv deriv temp)
  1609. X     (and (setq uinv (math-solve-for u
  1610. X                     math-integ-var-2
  1611. X                     math-integ-var nil))
  1612. X          (progn
  1613. X        (math-tracing-integral "Integrating by substitution, u = "
  1614. X                       (math-format-value u 1000)
  1615. X                       "\n")
  1616. X        (or (and (not (boundp 'math-disable-subst1))
  1617. X             (setq deriv (calcFunc-deriv u
  1618. X                             math-integ-var nil t))
  1619. X             (setq temp (math-integral (math-expr-subst
  1620. X                            (math-expr-subst
  1621. X                             (math-expr-subst
  1622. X                              (math-div expr deriv)
  1623. X                              u
  1624. X                              math-integ-var-2)
  1625. X                             math-integ-var
  1626. X                             uinv)
  1627. X                            math-integ-var-2
  1628. X                            math-integ-var)
  1629. X                           'yes)))
  1630. X            (and (not (boundp 'math-disable-subst2))
  1631. X             (setq deriv (calcFunc-deriv uinv
  1632. X                             math-integ-var-2
  1633. X                             math-integ-var t))
  1634. X             (setq temp (math-integral (math-mul
  1635. X                            (math-expr-subst
  1636. X                             (math-expr-subst
  1637. X                              (math-expr-subst
  1638. X                               expr
  1639. X                               u
  1640. X                               math-integ-var-2)
  1641. X                              math-integ-var
  1642. X                              uinv)
  1643. X                             math-integ-var-2
  1644. X                             math-integ-var)
  1645. X                            deriv)
  1646. X                           'yes)))))
  1647. X          (math-simplify-extended
  1648. X           (math-expr-subst temp math-integ-var u)))))
  1649. X)
  1650. X
  1651. X;;; Recursively try different substitutions based on various sub-expressions.
  1652. X(defun math-integ-try-substitutions (sub-expr)
  1653. X  (and (not (Math-primp sub-expr))
  1654. X       (math-expr-contains sub-expr math-integ-var)
  1655. X       (not (equal sub-expr math-integ-var))
  1656. X       (not (assoc sub-expr so-far))
  1657. X       (or (and (not (eq sub-expr expr))
  1658. X        (math-integrate-by-substitution expr sub-expr))
  1659. X       (let ((res nil))
  1660. X         (setq so-far (cons (list sub-expr) so-far))
  1661. X         (while (and (setq sub-expr (cdr sub-expr))
  1662. X             (not (setq res (math-integ-try-substitutions
  1663. X                     (car sub-expr))))))
  1664. X         res)))
  1665. X)
  1666. X
  1667. X(defun math-fix-const-terms (expr except-vars)
  1668. X  (cond ((not (math-expr-depends expr except-vars)) 0)
  1669. X    ((Math-primp expr) expr)
  1670. X    ((eq (car expr) '+)
  1671. X     (math-add (math-fix-const-terms (nth 1 expr) except-vars)
  1672. X           (math-fix-const-terms (nth 2 expr) except-vars)))
  1673. X    ((eq (car expr) '-)
  1674. X     (math-sub (math-fix-const-terms (nth 1 expr) except-vars)
  1675. X           (math-fix-const-terms (nth 2 expr) except-vars)))
  1676. X    (t expr))
  1677. X)
  1678. X
  1679. X(defun calc-dump-integral-cache (&optional arg)
  1680. X  "Command for debugging the Calculator's symbolic integrator."
  1681. X  (interactive "P")
  1682. X  (let ((buf (current-buffer)))
  1683. X    (unwind-protect
  1684. X    (let ((p math-integral-cache)
  1685. X          cur-record)
  1686. X      (display-buffer (get-buffer-create "*Integral Cache*")) 
  1687. X      (set-buffer (get-buffer "*Integral Cache*"))
  1688. X      (erase-buffer)
  1689. X      (while p
  1690. X        (setq cur-record (car p))
  1691. X        (or arg (math-replace-integral-parts cur-record))
  1692. X        (insert (math-format-flat-expr (car cur-record) 0)
  1693. X            " --> "
  1694. X            (if (symbolp (nth 1 cur-record))
  1695. X            (concat "(" (symbol-name (nth 1 cur-record)) ")")
  1696. X              (math-format-flat-expr (nth 1 cur-record) 0))
  1697. X            "\n")
  1698. X        (setq p (cdr p)))
  1699. X      (goto-char (point-min)))
  1700. X      (set-buffer buf)))
  1701. X)
  1702. X
  1703. X(defun calcFunc-integ (expr var &optional low high)
  1704. X  (let ((state (list calc-angle-mode
  1705. X             calc-symbolic-mode
  1706. X             calc-prefer-frac
  1707. X             calc-internal-prec)))
  1708. X    (or (equal state math-integral-cache-state)
  1709. X    (setq math-integral-cache-state state
  1710. X          math-integral-cache nil)))
  1711. X  (let* ((math-integ-level calc-integral-limit)
  1712. X     (math-integ-depth 0)
  1713. X     (math-integ-msg "Working...done")
  1714. X     (cur-record nil)   ; a technicality
  1715. X     (sexpr (math-expr-subst expr var math-integ-var))
  1716. X     (trace-buffer (get-buffer "*Trace*"))
  1717. X     (calc-language (if (eq calc-language 'big) nil calc-language))
  1718. X     (res (if trace-buffer
  1719. X          (let ((calcbuf (current-buffer))
  1720. X            (calcwin (selected-window)))
  1721. X            (unwind-protect
  1722. X            (progn
  1723. X              (if (get-buffer-window trace-buffer)
  1724. X                  (select-window (get-buffer-window trace-buffer)))
  1725. X              (set-buffer trace-buffer)
  1726. X              (goto-char (point-max))
  1727. X              (or (assq 'scroll-stop (buffer-local-variables))
  1728. X                  (progn
  1729. X                (make-local-variable 'scroll-step)
  1730. X                (setq scroll-step 3)))
  1731. X              (insert "\n\n\n")
  1732. X              (set-buffer calcbuf)
  1733. X              (math-integral sexpr 'yes))
  1734. X              (select-window calcwin)
  1735. X              (set-buffer calcbuf)))
  1736. X        (math-integral sexpr 'yes))))
  1737. X    (if res
  1738. X    (math-normalize
  1739. X     (if (and low high)
  1740. X         (math-sub (math-expr-subst res math-integ-var high)
  1741. X               (math-expr-subst res math-integ-var low))
  1742. X       (setq res (math-fix-const-terms res math-integ-vars))
  1743. X       (if low
  1744. X           (math-expr-subst res math-integ-var low)
  1745. X         (math-expr-subst res math-integ-var var))))
  1746. X      (append (list 'calcFunc-integ expr var)
  1747. X          (and low (list low))
  1748. X          (and high (list high)))))
  1749. X)
  1750. X
  1751. X(defmacro math-defintegral (funcs &rest code)
  1752. X  "Define an integration rule for the specified function.
  1753. XIf FUNCS is a list of functions, the same rule is applied for each function.
  1754. XCODE is a body of Lisp code that returns the integral of FUNCS(U).
  1755. XMore than one definition may be made per function.  All definitions are tried
  1756. Xin the order they were encountered; the first non-NIL value returned is used."
  1757. X  (setq math-integral-cache nil)
  1758. X  (append '(progn)
  1759. X      (mapcar (function
  1760. X           (lambda (func)
  1761. X             (list 'put (list 'quote func) ''math-integral
  1762. X               (list 'nconc
  1763. X                 (list 'get (list 'quote func) ''math-integral)
  1764. X                 (list 'list
  1765. X                       (list 'function
  1766. X                         (append '(lambda (u))
  1767. X                             code)))))))
  1768. X          (if (symbolp funcs) (list funcs) funcs)))
  1769. X)
  1770. X(put 'math-defintegral 'lisp-indent-hook 1)
  1771. X
  1772. X(defmacro math-defintegral-2 (funcs &rest code)
  1773. X  "Define an integration rule for the specified function.
  1774. XIf FUNCS is a list of functions, the same rule is applied for each function.
  1775. XCODE is a body of Lisp code that returns the integral of FUNCS(U,V).
  1776. XMore than one definition may be made per function.  All definitions are tried
  1777. Xin the order they were encountered; the first non-NIL value returned is used."
  1778. X  (setq math-integral-cache nil)
  1779. X  (append '(progn)
  1780. X      (mapcar (function
  1781. X           (lambda (func)
  1782. X             (list 'put (list 'quote func) ''math-integral-2
  1783. X               (list 'nconc
  1784. X                 (list 'get (list 'quote func)
  1785. SHAR_EOF
  1786. echo "End of part 9"
  1787. echo "File calc-ext.el is continued in part 10"
  1788. echo "10" > s2_seq_.tmp
  1789. exit 0
  1790.